home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / smaltalk / manchest.lha / MANCHESTER / usenet / st80_pre4 / navigation.st < prev    next >
Text File  |  1993-07-24  |  18KB  |  445 lines
  1. "    NAME        navigation
  2.     AUTHOR        holdam@daimi (Jan Holdam)
  3.     FUNCTION find class
  4.     ST-VERSIONS    2.1
  5.     PREREQUISITES     
  6.     CONFLICTS    find class in 2.2 onwards
  7.     DISTRIBUTION      world
  8.     VERSION        1.1
  9.     DATE    28 Nov 1986
  10. SUMMARY Adds a 'find class' item to the browser
  11. "
  12. '
  13. I would like to join the chorus of people submitting
  14. goodies for the Smalltalk-80 system. The goodies are
  15. developed for (or have been tested on) the PS-version
  16. of Smalltalk-80 running on Sun 3''s.
  17.  
  18. Alas, this goodie has similarities to the "findSelector"
  19. from Mario Wolczko, but nevertheless: what follows is
  20. a goodie for supporting navigation in the System Browser.
  21. It includes a version of the findClass where it is possible
  22. to type a wildcard specification of the class wanted, and
  23. where you may ask the system to look for other classes if
  24. the first guess is not what you wanted. The other main
  25. part of this navigation goodie is a findMethod which looks
  26. in the actual class for the method. If the method is not 
  27. found, you may choose the first guess, ask the system to
  28. try harder, or ask if the method is in the superclass of
  29. the class. The last part of this goodie is a facility
  30. to move from a class to its superclass, or to one of
  31. its subclasses (if any).
  32.  
  33. The goodie is not supposed to work correctly for
  34. multiple superclasses - at least it will only look
  35. for the first one.
  36.  
  37. Any comments to:
  38.  
  39. Jan Holdam
  40. Department of Computer Science
  41. Aarhus University
  42. DK-8000 Aarhus C
  43. Denmark
  44.  
  45. UUCP: holdam@daimi  or ..mcvax!!diku!!daimi!!holdam
  46. '
  47. 'From Smalltalk-80, version 2, of April 1, 1983 on 28 November 1986 at 12:40:32 pm'!
  48.  
  49.  
  50.  
  51. !Browser methodsFor: 'searching'!
  52.  
  53. chooseSelectorsAmong: selectors considering: aSelString 
  54.   "Find the selectors that match aSelString."
  55.  
  56.   ^selectors select: [:aSel | aSelString match: aSel]!
  57.  
  58. findClass
  59.   "Ask the user for the name of a class. If the name contains no wildcard characters
  60.   (* #) then answer the class having its name closest to the typed string, 
  61.   otherwise find all classes matching the string."
  62.  
  63.   | aString | 
  64.   self changeRequest ifFalse: [^self].
  65.   aString _ FillInTheBlank request: 'Find which class?' initialAnswer: 'ClassName'.
  66.   aString isEmpty ifTrue: [^self].
  67.   (aString includes: $*) | (aString includes: $#)
  68.     ifTrue: [^self findWildcardClass: aString].
  69.   ^self findClass: aString!
  70.  
  71. findClass: aClassString
  72.   "Test if the string denotes an existing class. If not, find the class closest to
  73.   aClassString and ask the user if that was the wanted class. If it isn't,
  74.   try other alternatives."
  75.  
  76.   | aClassName bestScore selectors score aStream menu reply showPoint | 
  77.   aClassName _ aClassString asSymbol.
  78.   (Smalltalk includesKey: aClassName)
  79.     ifTrue: [((Smalltalk at: aClassName) isKindOf: Behavior)
  80.           ifFalse: [^Transcript cr; 
  81.               show: aClassName, ' is a global instance of ', 
  82.               (Smalltalk at: aClassName) class printString]]
  83.     ifFalse:
  84.       ["find closest class"
  85.       bestScore _ 0.
  86.       Smalltalk classNames do: 
  87.         [:aClass | (score _ aClass spellAgainst: aClassString) > bestScore
  88.               ifTrue: [bestScore _ score. aClassName _ aClass]].
  89.  
  90.       aStream _ WriteStream on: (String new: 200).
  91.       aStream nextPutAll: 'correct? ', (aClassName contractTo: 25); cr.
  92.       aStream nextPutAll: 'try harder'.
  93.  
  94.       menu _ PopUpMenu labels: aStream contents.
  95.       reply _ menu startUp: #anyButton at: (showPoint _ Sensor cursorPoint) withHeading: ' ',
  96.           (aClassString contractTo: 25), ' is not a class'.
  97.  
  98.       reply == 0 ifTrue: [^self].
  99.       reply == 2
  100.         ifTrue: ["sort all class names with respect to the typed string, 
  101.             removing the one that has already been used"
  102.             Cursor execute showWhile: 
  103.               [selectors _ Smalltalk classNames copy.  
  104.               selectors remove: aClassName
  105.                    ifAbsent: [self error: 'Error while removing a class name'].
  106.               selectors _ self sortSelectors: selectors considering: aClassString].
  107.             ^self showAlternativesAmong: selectors at: showPoint string: aClassString]].
  108.  
  109.   self newClass: aClassName!
  110.  
  111. findMethod
  112.   "Ask the user for the name of a method. If it is the name of a unary or
  113.   binary selector, look for it. If it is the name of a keyword selector,
  114.   test if the name contains wildcard characters (* #). If it doesn't, answer the method
  115.   having its name closest to the typed string. If it does, find all methods 
  116.   matching the string."
  117.  
  118.   | aString | 
  119.   self changeRequest ifFalse: [^self].
  120.   aString _ FillInTheBlank request: 'Find which method?' initialAnswer: 'methodName'.
  121.   aString isEmpty ifTrue: [^self].
  122.   aString detect: [:aCharacter | aCharacter tokenish]
  123.     ifNone: [^self findMethod: aString inClass: self selectedClass showMenuAt: Sensor cursorPoint].
  124.   (aString includes: $*) | (aString includes: $#)
  125.     ifTrue: [^self findWildcardMethod: aString inClass: self selectedClass 
  126.         showMenuAt: Sensor cursorPoint].
  127.   ^self findMethod: aString inClass: self selectedClass showMenuAt: Sensor cursorPoint!
  128.  
  129. findMethod: aMethodString inClass: aClass showMenuAt: aPoint
  130.   "Test if the string denotes a method in aClass. If not, find the method closest to
  131.   aMethodString and ask the user if that was the wanted method. If it isn't,
  132.   try other alternatives in the same class, or look at methods in the superclass
  133.   (if any)."
  134.  
  135.   | aMethodName reply menu selectors aStream menuArray posInMenu showPoint |
  136.   aMethodName _ aMethodString asSymbol.
  137.   (aClass whichCategoryIncludesSelector: aMethodName) isNil
  138.   ifTrue: ["sort all method selectors with respect to the typed string"
  139.       Cursor execute 
  140.         showWhile: [selectors _ self sortSelectors: aClass selectors considering: aMethodString].
  141.   
  142.       "build menu"
  143.       menuArray _ Array new: 3.
  144.       posInMenu _ 0.
  145.       aStream _ WriteStream on: (String new: 200).
  146.       selectors isEmpty
  147.         ifFalse: [aMethodName _ selectors removeFirst.
  148.             posInMenu _ posInMenu + 1.
  149.             aStream nextPutAll: 'correct? ', (aMethodName contractTo: 25); cr.
  150.             selectors isEmpty
  151.               ifFalse: [aStream nextPutAll: 'try harder'; cr. 
  152.                   posInMenu _ posInMenu + 1.
  153.                   menuArray at: posInMenu put: #tryHarder]].
  154.       aClass ~= Object
  155.         ifTrue: [aStream nextPutAll: 'try in superclass'. 
  156.             posInMenu _ posInMenu + 1.
  157.             menuArray at: posInMenu put: #tryInSuperclass]
  158.         ifFalse: [aStream skip: -1].
  159.       posInMenu = 0 ifTrue: [^self].
  160.  
  161.       "now ask user"
  162.       menu _ ActionMenu labels: aStream contents selectors: menuArray.
  163.       reply _ menu startUp: #anyButton at: aPoint withHeading: ' ',
  164.           (aMethodString contractTo: 25), ' is not a method in ' , aClass name.
  165.  
  166.       reply == 0 ifTrue: [^self].
  167.       (menu selectorAt: reply) == #tryHarder
  168.         ifTrue: [^self showAlternativesAmong: selectors for: aClass at: aPoint string: aMethodString].
  169.       (menu selectorAt: reply) == #tryInSuperclass
  170.         ifTrue: [^self findMethod: aMethodString inClass: aClass superclass showMenuAt: aPoint]].
  171.  
  172.   self newSelector: aMethodName in: aClass.!
  173.  
  174. findSubclass
  175.   | aStream no classArray menu reply | 
  176.   "show the subclasses (if any) of the selected class in the browser, and
  177.   let the user choose among them"
  178.  
  179.   self changeRequest ifFalse: [^self].
  180.   self selectedClass = Object 
  181.     ifTrue: [^Transcript cr; show: 'Can not be used from Object'].
  182.   Cursor execute showWhile:
  183.     [aStream _ WriteStream on: (String new: 200).
  184.     classArray _ Array new: 50.
  185.     no _ 0.
  186.     self selectedClass subclasses do: 
  187.       [:aClass | 
  188.         aStream nextPutAll: aClass name; cr.
  189.         no _ no+1. 
  190.         no > 50 ifTrue: [Cursor normal show. ^Transcript cr; show: 'More than 50 subclasses'].
  191.         "to assure the menu will fit on the screen"
  192.         classArray at: no put: aClass].
  193.         no > 0 
  194.           ifTrue: [aStream skip: -1] 
  195.           ifFalse: [Cursor normal show. ^Transcript cr; show: 'No subclasses']].
  196.  
  197.   no = 1 ifTrue: [^self showNewClass: (classArray at: 1)].
  198.   menu _ PopUpMenu labels: aStream contents lines: (Array with: no).
  199.   (reply _ menu startUp: #anyButton at: Sensor cursorPoint
  200.       withHeading: '    Subclasses:    ') == 0 ifTrue: [^self].
  201.       
  202.   self showNewClass: (classArray at: reply).!
  203.  
  204. findSuperclass
  205.   "show the superclass (if any) of the selected class in the browser"
  206.  
  207.   self changeRequest ifFalse: [^self].
  208.   self selectedClass ~= Object ifTrue: 
  209.     [self showNewClass: self selectedClass superclass]!
  210.  
  211. findWildcardClass: aClassString
  212.   "Find all the classes that match aClassString, and let the user choose
  213.   among them. If no match, abort."
  214.  
  215.   | reply aStream no classArray classNames menu |
  216.   Cursor execute showWhile:
  217.     [classNames _ (self chooseSelectorsAmong: Smalltalk classNames considering: aClassString) asSortedCollection.
  218.     aStream _ WriteStream on: (String new: 200).
  219.     classArray _ Array new: 50.
  220.     no _ 0.
  221.     classNames do:
  222.       [:aClass | 
  223.         aStream nextPutAll: aClass; cr.
  224.         no _ no+1. 
  225.         no > 50 ifTrue: [Cursor normal show. ^Transcript cr; show: 'More than 50 classes matching'].
  226.         "to assure the menu will fit on the screen"
  227.         classArray at: no put: aClass].
  228.     no > 0 
  229.       ifTrue: [aStream skip: -1] 
  230.       ifFalse: [Cursor normal show. ^Transcript cr; show: 'No match']].
  231.  
  232.   menu _ PopUpMenu labels: aStream contents lines: (Array with: no).
  233.   (reply _ menu startUp: #anyButton at: Sensor cursorPoint
  234.     withHeading: 'Classes matching ', (aClassString contractTo: 25)) == 0 ifTrue: [^self].
  235.       
  236.   self newClass: (classArray at: reply).!
  237.  
  238. findWildcardMethod: aMethodString inClass: aClass showMenuAt: aPoint
  239.   "Find all the selectors in aClass that match aMethodString, and let the user choose
  240.   among them. If no match, the user may look at the superclass (if any)."
  241.  
  242.   | reply menu selectors aStream no selectorArray |
  243.   Cursor execute showWhile:
  244.     [selectors _ (self chooseSelectorsAmong: aClass selectors considering: aMethodString) asSortedCollection.
  245.     aStream _ WriteStream on: (String new: 200).
  246.     selectorArray _ Array new: 50.
  247.     no _ 0.
  248.     selectors do:
  249.       [:aSelector | 
  250.         aStream nextPutAll: (aSelector contractTo: 25); cr.
  251.         no _ no+1.
  252.         no > 50 ifTrue: [Cursor normal show. ^Transcript cr; show: 'More than 50 methods matching'].
  253.         "to assure the menu will fit on the screen"
  254.         selectorArray at: no put: aSelector]].
  255.   aClass ~= Object 
  256.     ifTrue: [aStream nextPutAll: 'try in superclass'] 
  257.     ifFalse: [no > 0 
  258.           ifTrue: [aStream skip: -1] 
  259.           ifFalse: [Cursor normal show. ^Transcript cr; show: 'No match']].
  260.  
  261.   menu _ PopUpMenu labels: aStream contents lines: (Array with: no).
  262.   reply _ no > 0 
  263.     ifTrue: [menu startUp: #anyButton at: aPoint withHeading: '  Methods matching ', 
  264.           (aMethodString contractTo: 25), ' in ', aClass name, '  ']
  265.     ifFalse: [menu startUp: #anyButton at: aPoint withHeading: '  No methods matching ',
  266.              (aMethodString contractTo: 25), ' in ', aClass name, '  ']. 
  267.  
  268.   reply == 0 ifTrue: [^self].
  269.   reply == (no+1)
  270.     ifTrue: [^self findWildcardMethod: aMethodString inClass: aClass superclass showMenuAt: aPoint].
  271.       
  272.   self newSelector: (selectorArray at: reply) in: aClass.!
  273.  
  274. newClass: aClassName
  275.   "Adjust the contents of the Browser."
  276.  
  277.   | aClass | 
  278.   aClass _ Smalltalk at: aClassName ifAbsent: [^self].
  279.   aClass category ~= category 
  280.     ifTrue: [self newCategoryList: aClass category].
  281.   ((aClass ~= self selectedClass) and: [aClass class ~= self selectedClass])
  282.     ifTrue: [self newClassList: aClassName].!
  283.  
  284. newSelector: aMethodName in: aClass
  285.   "Adjust the contents of the Browser."
  286.  
  287.   | newProtocol tempClass changeMeta |
  288.   changeMeta _ false.
  289.   (newProtocol _ (aClass whichCategoryIncludesSelector: aMethodName)) isNil ifTrue: [^self].
  290.   meta 
  291.     ifTrue: [((aClass ~= Object) & (aClass ~= Behavior) & (aClass ~= ClassDescription))
  292.         ifTrue: [tempClass _ aClass soleInstance]
  293.         ifFalse: [tempClass _ aClass.
  294.             changeMeta _ true]]
  295.     ifFalse: [tempClass _ aClass].
  296.   tempClass category ~= category 
  297.     ifTrue: [self newCategoryList: tempClass category].
  298.   tempClass ~= self selectedClass
  299.     ifTrue: [self newClassList: tempClass name asSymbol].
  300.   changeMeta ifTrue: [meta _ false. self changed: #meta]. 
  301.   protocol ~= newProtocol
  302.     ifTrue: [self newProtocolList: newProtocol].
  303.   selector ~= aMethodName   
  304.     ifTrue: [self newSelectorList: aMethodName].!
  305.  
  306. showAlternativesAmong: selectors at: aPoint string: aClassString
  307.   "Show the next 5 classes closest to aClassString that haven't been
  308.   shown before. Let the user choose among them, or decide to
  309.   continue with more imaginative proposals."
  310.  
  311.   | aStream reply no selectorArray sel | 
  312.   aStream _ WriteStream on: (String new: 200).
  313.   selectorArray _ Array new: 5.
  314.   no _ 0.
  315.   [no >= 5 or: [selectors isEmpty]]
  316.     whileFalse: [no _ no+1.
  317.           selectorArray at: no put: selectors removeFirst.
  318.           aStream nextPutAll: (selectorArray at: no); cr].
  319.   selectors isEmpty ifTrue: [aStream skip: -1]  ifFalse: [aStream nextPutAll: 'tryHarder'].
  320.   reply _ (PopUpMenu labels: aStream contents lines: (Array with: no)) startUp: #anyButton at: aPoint
  321.       withHeading: ' ', (aClassString contractTo: 25), ' is not a class'.
  322.   reply == 0 ifTrue: [^self].
  323.   reply = (no+1)
  324.     ifTrue: [^self showAlternativesAmong: selectors at: aPoint string: aClassString]
  325.     ifFalse: [^self newClass: (selectorArray at: reply)]!
  326.  
  327. showAlternativesAmong: selectors for: aClass at: aPoint string: aMethodString
  328.   "Show the next 5 selectors in aClass closest to aMethodString that haven't been
  329.   shown before. Let the user choose among them, decide to
  330.   continue with more imaginative proposals, or look at the superclass (if any)."
  331.  
  332.   | aStream reply no selectorArray menu | 
  333.   aStream _ WriteStream on: (String new: 200).
  334.   selectorArray _ Array new: 7.
  335.   no _ 0.
  336.   [no >= 5 or: [selectors isEmpty]]
  337.     whileFalse: [no _ no+1.
  338.           selectorArray at: no put: selectors removeFirst.
  339.           aStream nextPutAll: ((selectorArray at: no) contractTo: 25); cr].
  340.   selectors isEmpty
  341.     ifFalse: [aStream nextPutAll: 'try harder'; cr.
  342.         selectorArray at: no+1 put: #tryHarder].
  343.   aClass = Object
  344.     ifTrue: [aStream skip: -1]
  345.     ifFalse: [aStream nextPutAll: 'try in superclass'.
  346.         selectorArray at: (((selectorArray at: no+1) == nil) ifTrue: [no+1] ifFalse: [no+2])
  347.               put: #tryInSuperclass].
  348.   menu _ ActionMenu labels: aStream contents lines: (Array with: no) selectors: selectorArray.
  349.   reply _ menu startUp: #anyButton at: aPoint withHeading: ' ',
  350.       (aMethodString contractTo: 25), ' is not a method in ', aClass name.
  351.   reply == 0 ifTrue: [^self].
  352.   (menu selectorAt: reply) == #tryHarder
  353.     ifTrue: [^self showAlternativesAmong: selectors for: aClass at: aPoint string: aMethodString].
  354.   (menu selectorAt: reply) == #tryInSuperclass
  355.     ifTrue: [^self findMethod: aMethodString inClass: aClass superclass showMenuAt: aPoint].
  356.   ^self newSelector: (selectorArray at: reply) in: aClass!
  357.  
  358. showNewClass: aClass
  359.   | tempClass changeMeta | 
  360.   "Adjust the contents of the Browser."
  361.  
  362.   aClass isMeta
  363.     ifTrue: [tempClass _ aClass soleInstance.
  364.         changeMeta _ meta not]
  365.     ifFalse: [tempClass _ aClass.
  366.         changeMeta _ meta].
  367.   tempClass category ~= category 
  368.     ifTrue: [self newCategoryList: tempClass category].
  369.   ((tempClass ~= self selectedClass) and: [tempClass class ~= self selectedClass])
  370.     ifTrue: [self newClassList: tempClass name].
  371.   changeMeta
  372.     ifTrue: [self meta: meta not]!
  373.  
  374. sortSelectors: keys considering: aString
  375.   "Sort selectors with respect to being closest to aString. The intermediate
  376.   collection of arrays is used of effiency purposes."
  377.   
  378.   | selectors |  
  379.   selectors _ keys 
  380.     collect: [:sel | Array with: sel with: (sel spellAgainst: aString)].
  381.   ^(selectors asSortedCollection:
  382.     [:aSel :anotherSel | (aSel at: 2) > (anotherSel at: 2)])
  383.     collect: [:sel | sel at: 1]! !
  384.  
  385. !PopUpMenu methodsFor: 'controlling'!
  386.  
  387. startUp: aSymbol at: aPoint withHeading: aText
  388.   "Display and make a selection from the receiver as long as the button
  389.   denoted by the symbol, aSymbol, is pressed.  Answer the current selection."
  390.   
  391.   self displayAt: aPoint withHeading: aText
  392.     during: [Sensor cursorPoint: marker center.
  393.         [self buttonPressed: aSymbol]
  394.           whileFalse: [].
  395.         [self buttonPressed: aSymbol]
  396.           whileTrue: [self manageMarker]].
  397.   ^selection! !
  398.  
  399. !Browser methodsFor: 'category list'!
  400.  
  401. categoryMenu
  402.   "Browser flushMenus"
  403.   category == nil ifTrue:
  404.     [^ActionMenu labels: 'add category\update\edit all\find class' withCRs
  405.           lines: #(1 3)
  406.           selectors: #(addCategory updateCategories editCategories findClass)].
  407.   CategoryMenu == nil ifTrue:
  408.     [CategoryMenu _ ActionMenu
  409.       labels: 'file out\print out\spawn\add category\rename\remove\update\edit all\find class' withCRs
  410.       lines: #(3 7 9)
  411.       selectors: #(fileOutCategory printOutCategory spawnCategory addCategory renameCategory removeCategory updateCategories editCategories findClass)].
  412.   ^CategoryMenu! !
  413.  
  414.  
  415. !Browser methodsFor: 'class list'!
  416.  
  417. classMenu
  418.   "Browser flushMenus"
  419.   className == nil ifTrue: [^nil].
  420.   ClassMenu == nil ifTrue:
  421.     [ClassMenu _ ActionMenu
  422.       labels: 'file out\print out\spawn\spawn hierarchy\hierarchy\definition\comment\protocols\inst var refs\class var refs\class refs\rename\remove\superclass\subclass' withCRs
  423.       lines: #(4 9 12 14)
  424.       selectors: #(fileOutClass printOutClass spawnClass spawnHierarchy  
  425. showHierarchy editClass editComment editProtocols
  426. browseFieldReferences browseClassVariables browseClassReferences
  427.  renameClass removeClass
  428. findSuperclass findSubclass)].
  429.   ^ClassMenu! !
  430.  
  431. !Browser methodsFor: 'protocol list'!
  432.  
  433. protocolMenu
  434.   "Browser flushMenus"
  435.   protocol == nil ifTrue:
  436.     [^ActionMenu labels: 'add protocol\find method' withCRs
  437.             lines: #(1)
  438.             selectors: #(addProtocol findMethod)].
  439.   ProtocolMenu == nil ifTrue:
  440.     [ProtocolMenu _ ActionMenu
  441.       labels: 'file out\print out\spawn\add protocol\rename\remove\find method' withCRs
  442.       lines: #(3 7)
  443.       selectors: #(fileOutProtocol printOutProtocol spawnProtocol addProtocol renameProtocol removeProtocol findMethod)].
  444.    ^ProtocolMenu! !
  445.